home *** CD-ROM | disk | FTP | other *** search
/ Inter.Net 55-2 / Inter.Net 55-2.iso / Mandrake / mdkinst / usr / lib / perl5 / 5.00503 / Exporter.pm < prev    next >
Encoding:
Perl POD Document  |  2000-01-12  |  5.8 KB  |  232 lines
  1. package Exporter;
  2.  
  3. require 5.001;
  4.  
  5. #
  6. # We go to a lot of trouble not to 'require Carp' at file scope,
  7. #  because Carp requires Exporter, and something has to give.
  8. #
  9.  
  10. $ExportLevel = 0;
  11. $Verbose = 0 unless $Verbose;
  12.  
  13. sub export {
  14.  
  15.     # First make import warnings look like they're coming from the "use".
  16.     local $SIG{__WARN__} = sub {
  17.     my $text = shift;
  18.     if ($text =~ s/ at \S*Exporter.pm line \d+.*\n//) {
  19.         require Carp;
  20.         local $Carp::CarpLevel = 1;    # ignore package calling us too.
  21.         Carp::carp($text);
  22.     }
  23.     else {
  24.         warn $text;
  25.     }
  26.     };
  27.     local $SIG{__DIE__} = sub {
  28.     require Carp;
  29.     local $Carp::CarpLevel = 1;    # ignore package calling us too.
  30.     Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
  31.         if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
  32.     };
  33.  
  34.     my($pkg, $callpkg, @imports) = @_;
  35.     my($type, $sym, $oops);
  36.     *exports = *{"${pkg}::EXPORT"};
  37.  
  38.     if (@imports) {
  39.     if (!%exports) {
  40.         grep(s/^&//, @exports);
  41.         @exports{@exports} = (1) x @exports;
  42.         my $ok = \@{"${pkg}::EXPORT_OK"};
  43.         if (@$ok) {
  44.         grep(s/^&//, @$ok);
  45.         @exports{@$ok} = (1) x @$ok;
  46.         }
  47.     }
  48.  
  49.     if ($imports[0] =~ m#^[/!:]#){
  50.         my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
  51.         my $tagdata;
  52.         my %imports;
  53.         my($remove, $spec, @names, @allexports);
  54.         # negated first item implies starting with default set:
  55.         unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
  56.         foreach $spec (@imports){
  57.         $remove = $spec =~ s/^!//;
  58.  
  59.         if ($spec =~ s/^://){
  60.             if ($spec eq 'DEFAULT'){
  61.             @names = @exports;
  62.             }
  63.             elsif ($tagdata = $tagsref->{$spec}) {
  64.             @names = @$tagdata;
  65.             }
  66.             else {
  67.             warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
  68.             ++$oops;
  69.             next;
  70.             }
  71.         }
  72.         elsif ($spec =~ m:^/(.*)/$:){
  73.             my $patn = $1;
  74.             @allexports = keys %exports unless @allexports; # only do keys once
  75.             @names = grep(/$patn/, @allexports); # not anchored by default
  76.         }
  77.         else {
  78.             @names = ($spec); # is a normal symbol name
  79.         }
  80.  
  81.         warn "Import ".($remove ? "del":"add").": @names "
  82.             if $Verbose;
  83.  
  84.         if ($remove) {
  85.            foreach $sym (@names) { delete $imports{$sym} } 
  86.         }
  87.         else {
  88.             @imports{@names} = (1) x @names;
  89.         }
  90.         }
  91.         @imports = keys %imports;
  92.     }
  93.  
  94.     foreach $sym (@imports) {
  95.         if (!$exports{$sym}) {
  96.         if ($sym =~ m/^\d/) {
  97.             $pkg->require_version($sym);
  98.             # If the version number was the only thing specified
  99.             # then we should act as if nothing was specified:
  100.             if (@imports == 1) {
  101.             @imports = @exports;
  102.             last;
  103.             }
  104.             # We need a way to emulate 'use Foo ()' but still
  105.             # allow an easy version check: "use Foo 1.23, ''";
  106.             if (@imports == 2 and !$imports[1]) {
  107.             @imports = ();
  108.             last;
  109.             }
  110.         } elsif ($sym !~ s/^&// || !$exports{$sym}) {
  111.                     require Carp;
  112.             Carp::carp(qq["$sym" is not exported by the $pkg module]);
  113.             $oops++;
  114.         }
  115.         }
  116.     }
  117.     if ($oops) {
  118.         require Carp;
  119.         Carp::croak("Can't continue after import errors");
  120.     }
  121.     }
  122.     else {
  123.     @imports = @exports;
  124.     }
  125.  
  126.     *fail = *{"${pkg}::EXPORT_FAIL"};
  127.     if (@fail) {
  128.     if (!%fail) {
  129.         # Build cache of symbols. Optimise the lookup by adding
  130.         # barewords twice... both with and without a leading &.
  131.         # (Technique could be applied to %exports cache at cost of memory)
  132.         my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail;
  133.         warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose;
  134.         @fail{@expanded} = (1) x @expanded;
  135.     }
  136.     my @failed;
  137.     foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} }
  138.     if (@failed) {
  139.         @failed = $pkg->export_fail(@failed);
  140.         foreach $sym (@failed) {
  141.                 require Carp;
  142.         Carp::carp(qq["$sym" is not implemented by the $pkg module ],
  143.             "on this architecture");
  144.         }
  145.         if (@failed) {
  146.         require Carp;
  147.         Carp::croak("Can't continue after import errors");
  148.         }
  149.     }
  150.     }
  151.  
  152.     warn "Importing into $callpkg from $pkg: ",
  153.         join(", ",sort @imports) if $Verbose;
  154.  
  155.     foreach $sym (@imports) {
  156.     # shortcut for the common case of no type character
  157.     (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
  158.         unless $sym =~ s/^(\W)//;
  159.     $type = $1;
  160.     *{"${callpkg}::$sym"} =
  161.         $type eq '&' ? \&{"${pkg}::$sym"} :
  162.         $type eq '$' ? \${"${pkg}::$sym"} :
  163.         $type eq '@' ? \@{"${pkg}::$sym"} :
  164.         $type eq '%' ? \%{"${pkg}::$sym"} :
  165.         $type eq '*' ?  *{"${pkg}::$sym"} :
  166.         do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
  167.     }
  168. }
  169.  
  170. sub export_to_level
  171. {
  172.       my $pkg = shift;
  173.       my ($level, $junk) = (shift, shift);  # need to get rid of first arg
  174.                                             # we know it already.
  175.       my $callpkg = caller($level);
  176.       $pkg->export($callpkg, @_);
  177. }
  178.  
  179. sub import {
  180.     my $pkg = shift;
  181.     my $callpkg = caller($ExportLevel);
  182.     export $pkg, $callpkg, @_;
  183. }
  184.  
  185.  
  186.  
  187. # Utility functions
  188.  
  189. sub _push_tags {
  190.     my($pkg, $var, $syms) = @_;
  191.     my $nontag;
  192.     *export_tags = \%{"${pkg}::EXPORT_TAGS"};
  193.     push(@{"${pkg}::$var"},
  194.     map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) }
  195.         (@$syms) ? @$syms : keys %export_tags);
  196.     if ($nontag and $^W) {
  197.     # This may change to a die one day
  198.     require Carp;
  199.     Carp::carp("Some names are not tags");
  200.     }
  201. }
  202.  
  203. sub export_tags    { _push_tags((caller)[0], "EXPORT",    \@_) }
  204. sub export_ok_tags { _push_tags((caller)[0], "EXPORT_OK", \@_) }
  205.  
  206.  
  207. # Default methods
  208.  
  209. sub export_fail {
  210.     my $self = shift;
  211.     @_;
  212. }
  213.  
  214. sub require_version {
  215.     my($self, $wanted) = @_;
  216.     my $pkg = ref $self || $self;
  217.     my $version = ${"${pkg}::VERSION"};
  218.     if (!$version or $version < $wanted) {
  219.     $version ||= "(undef)";
  220.     my $file = $INC{"$pkg.pm"};
  221.     $file &&= " ($file)";
  222.     require Carp;
  223.     Carp::croak("$pkg $wanted required--this is only version $version$file")
  224.     }
  225.     $version;
  226. }
  227.  
  228. 1;
  229.  
  230. # A simple self test harness. Change 'require Carp' to 'use Carp ()' for testing.
  231. # package main; eval(join('',<DATA>)) or die $@ unless caller;
  232.